
-[public] enum code_kind {
	-[ for each word, begin ]
		-[ words ] -[code names]
		-[output]
			code_%w, 
	-[ end ]
};

=[ code names ]
	add  sub  div  mul  mod 
	jump  label  cjump 
	less  lesse  great  greate 
	equal  nequal 
	store 
	fcall  pcall  freturn preturn
=[]


-[public] enum carg_kind { carg_varref,
	carg_intconst,
	/* this should really point to an ufunc but for now,
	   we will make do with a symbol */
	carg_funcref };

-[public] typedef struct {
	enum carg_kind kind;
	union {
		variable_t *varref;
		int intconst;
		char *symbol;
	} d;
} carg_t;

-[public] typedef struct {
	enum code_kind kind;
	int nargs;
	carg_t* args;
} code_t;

-[ codelist_t : public list of code_t* ]

-[public] typedef struct {
	linenumber_t *linenumber;
	char *name;
	char *gname;
	varlist_t *args;
	varlist_t *vars;
	codelist_t *code;
	utermlist_t *uncompiled;
	type_t *return_type;
} ufunc_t;

-[ufunclist_t : public list of ufunc_t* ]

-[ public] ufunclist_t *ufuncs;
+[ pfunc init ]
	ufuncs= ufunclist_new();
+[ end ]

-[public] void compile_func_body
	(ufunc_t *func)
{
	uterm_t *T;
	operand_t OP;
	parser_t *parser;
	variable_t *V;

	parser= parser_new(func->uncompiled,0);

	-[list>for K ∈ *func->args, begin ]
		pfunc_t *CF;
		CF= pfunc_new(pfunc_builtin, strdup(K->name),
			func->linenumber,
			closure_new(pushvar_closure));
		closure_set(CF->d.builtin, "var", K);
		pflist_append(parser_top_context(parser), CF);
	-[end]

again:
	T= utermlist_destroy(parser->body);
	if (!T) goto done;

	switch(T->kind) {
		case ut_number:
			if (!parser->expect_term)  
				reduce_stack(parser,0);
			OP.kind= operand_intconst;
			OP.d.intv= strtol(T->data,0,0);
			OP.code= 0;
			astack_push(parser->astack, OP);
			parser->expect_term= 0;
			goto again;
		case ut_strlit:
			callhistory_push(callhistory, T->linenumber);
			print_error_exit("string literals are not "
			  "implemented yet :)\n");
			break;
		case ut_macroarg: case ut_nmacroarg:
		case ut_smacroarg: case ut_wmacroarg:
			callhistory_push(callhistory, T->linenumber);
			print_error_exit("macro arguments are only "
				"valid in match statements\n");
			break;
		case ut_cu_bulk:
			run_curly_expr(parser,T->body,T->linenumber);
			goto again;
		case ut_ro_bulk: case ut_sq_bulk:
			callhistory_push(callhistory, T->linenumber);
			print_error_exit("parenthesis are not "
			  "implemented yet :)\n");
			break;
		 case ut_word:
			break;
	}

	if ((V=find_var(parser,T->data))) {
		if (!parser->expect_term)  
			reduce_stack(parser,0);
		OP.kind= operand_varref;
		OP.d.varref= V;
		OP.code= 0;
		astack_push(parser->astack, OP);
		parser->expect_term= 0;
		goto again;
	}

	pfunc_call(T->data, T->linenumber, parser,
			uglobal_context,func->code);
	goto again;

done:
	func->vars= parser->vars;
}

-[private] ufunc_t *cufunc;


/* FIXME: we should avoid the above global
   variable. instead, the beginfunc function
   should re-define the _funcarg and similar
   macros as new closures which have an
   argument called 'func'. this argument then
   could be set to the newly created function object */
-[ simple 1-arg builtin _beginfunc, scope "C" ] {
	uterm_t *name;
	utermlist_toarray(a1,&name,1);
	-[ allocate object cufunc ]
	cufunc->args= varlist_new();
	cufunc->code= codelist_new();
	cufunc->name= strdup(name->data);
	cufunc->vars= 0; /* will get this from the body */
	cufunc->linenumber= name->linenumber;
	cufunc->return_type= 0;
}

-[ simple 2-arg builtin _beginfuncwreturn, scope "C" ] {
	uterm_t *name;
	utermlist_toarray(a1,&name,1);
	-[ allocate object cufunc ]
	cufunc->args= varlist_new();
	cufunc->code= codelist_new();
	cufunc->name= strdup(name->data);
	cufunc->vars= 0; /* will get this from the body */
	cufunc->linenumber= name->linenumber;
	cufunc->return_type= parse_type(parser,a2);
}


-[ simple 2-arg builtin _funcarg, scope "C" ] {
	uterm_t *name;
	utermlist_t *type;
	variable_t *V;
	utermlist_toarray(a1,&name,1);
	type= a2;

	V= variable_new(name->data, parse_type(parser,type));
	varlist_append(cufunc->args, V);
}

-[ simple 1-arg builtin _endfunc, scope "C" ] {
	static int last= 1;
	closure_t *C;
	static linenumber_t L = { "FIXME: BUILTIN-endfunc", 1 };
	cufunc->gname= mprintf("_func_%s_%d",
		cufunc->name, last++);
	cufunc->uncompiled= utermlist_deep_copy(a1);
	ufunclist_append(ufuncs, cufunc);

	C= closure_new(begin_fcall_closure);
	closure_set(C, "ufunc", cufunc);
	pflist_append(uglobal_context,
		pfunc_new(pfunc_builtin,
			strdup(cufunc->name), &L, C));

	cufunc= 0;
}

-[public] void compile_user_functions() {
	-[list>for K ∈ *ufuncs, begin ]
		compile_func_body(K);
		dump_func(K);
	-[end]
}

-[closure begin_fcall, begin ]
	-[ arg ufunc : ufunc_t*]
	-[ arg parser : parser_t*]
	-[ arg success : int*]
	-[ function is private ]
	-[ closure is private ]
-[end]  {
	uterm_t *pl;
	char buf[200];
	static int last=0;
	int mark;
	closure_t *C;
	static linenumber_t L = { "FIXME: BUILTIN-begin_fcall", 1 };

	*success= 0;
	if (utermlist_isempty(parser->body))
		return ;
	pl= utermlist_destroy(parser->body);
	if (pl->kind!=ut_ro_bulk) {
		utermlist_prepend(parser->body,pl);
		return ;
	}

	*success= 1;
	mark= parser->astack->nelts;
	last++;

	sprintf(buf,"_fcall_end_%d", last);
	C= closure_new(fcall_end_closure);
	closure_set(C, "funcname", ufunc->name);
	closure_set(C, "stackmark", mark);
	pflist_append(parser_top_context(parser),
		pfunc_new(pfunc_builtin, strdup(buf), &L, C));
	
	utermlist_prepend(parser->body,
		uterm_simple(ut_word, strdup(buf), &L));
	run_curly_expr(parser, pl->body, pl->linenumber);
}


-[closure fcall_end, begin ]
	-[ arg funcname : char* ]
	-[ arg stackmark : int ]
	-[ arg parser : parser_t*]
	-[ arg success : int*]
	-[ function is private ]
	-[ closure is private ]
-[end]  {
	operand_t *actual;
	int nactual;
	actual= 0;
	*success= 0;
	nactual= parser->astack->nelts- stackmark;
	if (nactual) {
		int i;
		-[ actual = allocate array nactual ]
		for(i=0;i<nactual;i++)
			actual[i]= parser->astack->elts[stackmark+i];
		parser->astack->nelts= stackmark;
	}

	-[list>for F ∈ *ufuncs, begin ]
		if (!strcmp(F->name, funcname)) {
			if (try_dispatch(F, parser, nactual, actual)) {
				*success= 1;
				/* FIXME: also free contents here */
				if (actual)
					free(actual);
				return ;
			}	
		}
	-[end]
}

-[private] int try_dispatch
	(ufunc_t *F, parser_t *parser, int nactual, operand_t *actual)
{
	char buf[20];
	int fcount;
	utermlist_t *arglist;
	utermlist_t *all_code;
	operand_t final;
	int i;
	type_t int_type= { .basic= { type_basic,  basic_int }};
	static linenumber_t L = { "FIXME: BUILTIN-try_dispatch", 1 };

	fcount= 0;
	-[list> for A ∈ *F->args, begin ]
		fcount++;
	-[end]

	if (nactual!=fcount) 
		return 0;

	if (nactual==0) 
		goto do_dispatch;

	i= 0;
	-[list> for A ∈ *F->args, begin ]
		type_t *T;
		switch(actual[i].kind) {
		case operand_utermlist:
		case operand_type:
		case operand_void:
			return 0;
		case operand_varref:
			T= actual[i].d.varref->type;
			break;
		case operand_intconst:
			T= &int_type;
			break;
		}
		if (!types_equal(A->type,T))
			return 0;
		i++;
	-[end]

do_dispatch:

	arglist= utermlist_new();

	all_code= utermlist_new();
	for(i=0;i<nactual;i++) {
		utermlist_append(arglist,
			uterm_cu_bulk(
				operand_to_utermlist(parser, actual+i, &L),
			&L));
		if (actual[i].code)
			utermlist_append_destructive
				(all_code, actual[i].code);
	}

	if (F->return_type)
		-[ push function call ]
	else
		-[ push procedure call ]
	return 1;

}

=[ push procedure call ] {

	utermlist_append(all_code, 
		uterm_simple(ut_word, strdup("_pcall"), &L));

	utermlist_append(all_code, uterm_cu_bulk_of_one(
		uterm_simple(ut_word, strdup(F->gname), &L)));
		
	sprintf(buf,"%d",nactual);
	utermlist_append(all_code, uterm_cu_bulk_of_one(
		uterm_simple(ut_number, strdup(buf), &L)));

	utermlist_append_destructive(all_code, arglist);
	final.kind= operand_void;
	final.code= all_code;
	astack_push(parser->astack, final);
	parser->expect_term= 1;
}


=[push function call ] {
	char *ret_var_name;
	static int last= 0;
	variable_t *ret_var;

	ret_var_name= mprintf("_retvalue_%s_%d", F->name, last++);
	ret_var= variable_new(ret_var_name, F->return_type);
	varlist_append(parser->vars, ret_var);

	utermlist_append(all_code, 
		uterm_simple(ut_word, strdup("_fcall"), &L));

	utermlist_append(all_code, uterm_cu_bulk_of_one(
		uterm_simple(ut_word, strdup(F->gname), &L)));
		
	sprintf(buf,"%d",nactual);
	utermlist_append(all_code, uterm_cu_bulk_of_one(
		uterm_simple(ut_number, strdup(buf), &L)));

	utermlist_append(all_code, uterm_cu_bulk_of_one(
		uterm_simple(ut_word, strdup(ret_var_name), &L)));

	utermlist_append_destructive(all_code, arglist);
	final.kind= operand_varref;
	final.code= all_code;
	final.d.varref= ret_var;
	astack_push(parser->astack, final);
	parser->expect_term= 0;
}

=[]




-[public] void utermlist_to_carg
	(parser_t *parser,utermlist_t *terms, carg_t *arg)
{
	uterm_t *T;
	operand_t D;
	int nelts;
	variable_t *V;

	T= 0;
	utermlist_toarray(terms, &T,1);
	if (!T) 
		print_error_exit("empty utermlist given to "
				"utermlist_to_carg\n");
	switch(T->kind) {
	case ut_number:
		arg->kind= carg_intconst;
		/* FIXME: use strtol here */
		arg->d.intconst= atoi(T->data);
		break;
	case ut_word:
		if ((V=find_var(parser,T->data))) {
			arg->kind= carg_varref;
			arg->d.varref= V;
			break;
		}
		nelts= parser->astack->nelts;
		pfunc_call(T->data, T->linenumber,
				parser, global_context,0);
		if (parser->astack->nelts<=nelts)
			print_error_exit("stack underflow during "
				"conversion of utermlist to cargs.\n"
				"called function is %s:\n", T->data);
		D= astack_pop(parser->astack);
		parser->astack->nelts= nelts;
		operand_to_carg(&D, arg);
		break;
	case ut_strlit:
	case ut_macroarg: case ut_nmacroarg:
	case ut_smacroarg: case ut_wmacroarg:
	case ut_ro_bulk: case ut_sq_bulk: case ut_cu_bulk:
		print_error_exit("invalid kind of token in "
			"convert_utermlist_to_carg\n");
		break;
	}
}


-[public] void operand_to_carg(operand_t *D,carg_t *A)
{
	switch(D->kind) {
	case operand_varref:
		A->kind= carg_varref;
		A->d.varref= D->d.varref;
		break;
	case operand_intconst:
		A->kind= carg_intconst;
		A->d.intconst= D->d.intv;
		break;
	case operand_type:
	case operand_void:
	case operand_utermlist:
		print_error_exit("trying to convert an utermlist,void or "
		"a type to a carg\n");
		break;
	}
}

-[public] void dump_func(ufunc_t *F)
{
	printf("FUNCTION (%s:%s)\n",F->gname,F->name);
	printf("ARGS\n");
	print_varlist(F->args);
	printf("VARS\n");
	print_varlist(F->vars);
	printf("CODE\n");
	print_codelist(F->code);
}


-[public] void print_varlist(varlist_t *VL) {
	-[ list>for V ∈ *VL, begin ]
		print_var(V);
	-[end] }

-[public] void print_codelist(codelist_t *VL) {
	-[ list>for V ∈ *VL, begin ]
		print_code(V);
	-[end] }

-[public] void print_var(variable_t *V) {
	printf("variable %s: ", V->name);
	dump_type(V->type);
	printf("\n");
}

-[public] void print_code(code_t *C) {
	int i;
	switch(C->kind) {
	-[ for each word, begin ]
		-[ words ] -[ code names ]
		-[ output ]
			case code_%w: printf("%w "); break;
	-[ end ]
	}
	for(i=0;i<C->nargs;i++)
		print_carg(C->args+i);
	printf("\n");
}

=[ print case : $F / $N ] 
	case code_$F: printf("%s ", -[stringify $F]); N= $N; break;
=[]

-[public] void print_carg(carg_t *A) {
	switch(A->kind) {
	case carg_varref: printf("V(%s) ", A->d.varref->name); break;
	case carg_intconst: printf("%d ", A->d.intconst); break;
	case carg_funcref: printf("F(%s) ",A->d.symbol); break;
	}
}

-[public] code_t* code_new(enum code_kind kind,int nargs)
{
	code_t *C;
	-[allocate object C]
	C->kind= kind;
	C->nargs= nargs;
	if (nargs)
		-[ C->args= allocate array nargs ]
	return C;
}

-[builtin[U] return]
{
	linenumber_t L= { "[builtin-return]", 1 };
	pflist_t *bindings;

	-[ bindings= parser->body ~ "$VALUE;" ]
	if (bindings) {
		utermlist_t *value;
		*success= 1;
		value= get_macro_arg(parser,bindings,"VALUE");
		parser_prepend_call(parser, "_return_with_value");
		run_curly_expr(parser, value, &L);
	} else {
		-[ bindings= parser->body ~ ";" ]
		if (!bindings)
			return ;
		*success= 1;
		parser_prepend_call(parser, "_preturn");
	}
}

-[ builtin[CU] _return_with_value ]
{
	operand_t V;
	linenumber_t L= { "[builtin-returnvalue]", 1 };
	if (astack_isempty(parser->astack))
		print_error_exit("void argument given to "
				"'return' statement");
	V= astack_pop(parser->astack);
	parser_prepend_assembly_call(parser, "_freturn",
		operand_to_utermlist(parser,&V,&L),0);
	*success=1;
}

-[ low level builtin _freturn:1, begin ]
	-[ simple compiler for freturn with 1 args ]
-[ end ]

-[ low level builtin _preturn:0, begin ]
	-[ simple compiler for preturn with 0 args ]
-[ end ]


